home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / Modules / eubang.em < prev    next >
Lisp/Scheme  |  1992-07-15  |  15KB  |  592 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9.  
  10.  
  11.  
  12.  
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19.  
  20.  
  21.  
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31.  
  32.  
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39.  
  40.  
  41.  
  42.  
  43.  
  44.  
  45.  
  46.  
  47.  
  48.  
  49.  
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56.  
  57.  
  58.  
  59.  
  60.  
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117. (defmodule eubang (standard0 plural) ()
  118.  
  119.   (setq MasPar-X-Config 16)
  120.   (setq MasPar-Y-Config 32)
  121.  
  122.   (defclass xec ()
  123.     ((context
  124.       initarg context
  125.       reader  cntext)
  126.      (offset
  127.       initarg offset
  128.       reader  offset))
  129.     constructor (allocate-xec context offset)
  130.     predicate xecp)
  131.  
  132.   (defun make-xec (c o)
  133.     (become-strange (allocate-xec c o)))
  134.   
  135.   (defmethod generic-prin ((p xec) str)
  136.     (format str "#x(")
  137.     (mp-print (cntext p) (offset p) str)
  138.     (format str ")")
  139.     p)
  140.   
  141.   (defmethod generic-write ((p xec) str)
  142.     (format str "#x(")
  143.     (mp-print (cntext p) (offset p) str)
  144.     (format str ")")
  145.     p)
  146.  
  147.   (defclass paralation-internal ()
  148.     ((context
  149.       initarg context
  150.       reader context-internal)
  151.      (size
  152.       initarg size
  153.       reader length-internal))
  154.     constructor (allocate-paralation context size)
  155.     predicate paralationp)
  156.  
  157.   (defun make-paralation (size)
  158.     (let* ((height (+ (/ size MasPar-X-Config) 
  159.               (if (zerop (remainder size MasPar-X-Config)) 0 1)))
  160.        (ctxt (mp-make-context (if (= height 1) size MasPar-X-Config)
  161.                   height))
  162.        (ofst (mp-context ctxt))
  163.        (enum (mp-scan-op ctxt (mp-bang ctxt 1)     610)))
  164.       (mp-if ctxt (mp-rel-op ctxt enum (mp-bang ctxt size)     652))
  165.       (mp-else ctxt)
  166.       (mp-assign ctxt ofst (mp-bang ctxt '(() ())))
  167.       (mp-fi ctxt)
  168.       (allocate-paralation ctxt size)))
  169.  
  170.   (defclass mp-object ()
  171.     ((paralation
  172.       initarg paralation
  173.       reader paralation)
  174.      (offset
  175.       initarg offset
  176.       reader  offset))
  177.     predicate mp-object-p)
  178.  
  179.   (defun context (mp-o) (context-internal (paralation mp-o)))
  180.  
  181.   (defclass plural (mp-object)
  182.     ()
  183.     constructor (allocate-plural paralation offset)
  184.     predicate pluralp)
  185.  
  186.   (defmethod generic-prin ((p plural) str)
  187.     (format str "#P(")
  188.     (mp-print (context p) (offset p) () () str)
  189.     (format str ")")
  190.     p)
  191.  
  192.   (defmethod generic-write ((p plural) str)
  193.     (format str "#P(")
  194.     (mp-print (context p) (offset p) () () str)
  195.     (format str ")")
  196.     p)
  197.  
  198.   (defun make-plural (n-or-plural)
  199.     (cond 
  200.      ((eq (class-of n-or-plural) integer)
  201.       (let ((new-paralation (make-paralation n-or-plural)))
  202.     (become-strange (allocate-plural new-paralation
  203.                      (mp-make-plural (context-internal 
  204.                               new-paralation))))))
  205.      ((pluralp n-or-plural)
  206.       (become-strange (allocate-plural (paralation n-or-plural) 
  207.                        (mp-make-plural (context 
  208.                             n-or-plural)))))
  209.      (t (error "Aaaeeii, wot dis in make-plural?" clock-tick))))
  210.  
  211.   (defun plural-length (object)
  212.     (if (pluralp object) (length-internal (paralation object))
  213.       (error "Arg1 not a plural" clock-tick)))
  214.  
  215.   (defun plural-ref (plural index)
  216.     (cond
  217.      ((not (pluralp plural)) (error "Arg1 not a plural" clock-tick))
  218.      ((not (eq (class-of index) integer)) 
  219.       (error "Arg2 not an integer" clock-tick))
  220.      (t (mp-ref (context plural) (offset plural) index))))
  221.  
  222.   ((setter setter) plural-ref
  223.      (lambda (plural index value)
  224.      (cond
  225.       ((not (pluralp plural)) (error "Arg1 not a plural" clock-tick))
  226.       ((not (eq (class-of index) integer))
  227.        (error "Arg2 not an integer" clock-tick))
  228.       (t (mp-set (context plural) (offset plural) index value)))
  229.      plural))
  230.  
  231.   (defun if-s-internal (bool consc antec)
  232.     (let ((result (make-plural bool)))
  233.       (if (mp-if (context bool) (offset bool))
  234.     (let ((consc-result (consc)))
  235.       (if (pluralp consc-result)
  236.         (mp-assign (context result) (offset result) 
  237.                (offset consc-result))
  238.         ())) ())
  239.       (if (mp-else (context bool))
  240.     (let ((antec-result (antec)))
  241.       (if (pluralp antec-result)
  242.         (mp-assign (context result) (offset result)
  243.                (offset antec-result))
  244.         ())) ())
  245.       (mp-fi (context bool))
  246.       result))
  247.  
  248.   (defmacro if-s (bool consc antec)
  249.     `(if-s-internal ,bool (lambda () ,consc) (lambda () ,antec)))
  250.  
  251.   (defun list-to-plural (list . plurals)
  252.     (if (or (null plurals) (pluralp (car plurals)))
  253.       (let ((new (if (null plurals) (make-plural (list-length list))
  254.            (make-plural (car plurals)))))
  255.     (labels ((recurse (index list)
  256.            (mp-set (context new) (offset new) index (car list))
  257.            (if (or (zerop index) (null (cdr list))) new
  258.              (recurse (- index 1) (cdr list)))))
  259.       (recurse (- (list-length list) 1) (reverse list))))
  260.       (error "Arg2 not a plural" clock-tick)))
  261.  
  262.   (defun conformantp (arg1 arg2)
  263.     (cond 
  264.      ((not (pluralp arg1)) ())
  265.      ((not (pluralp arg2)) ())
  266.      (t (eq (context arg1) (context arg2)))))
  267.  
  268.   (defun bang (object plural)
  269.     (if (pluralp plural)
  270.       (allocate-plural (paralation plural) (mp-bang (context plural) object))
  271.       (error "Arg2 not a plural" clock-tick)))
  272.  
  273.   (defun auto-bang (arg1 arg2 fn)
  274.     (cond
  275.      ((not (or (pluralp arg1) (pluralp arg2)))
  276.       (error "Neither argument is a plural" clock-tick))
  277.      ((and (pluralp arg1) (pluralp arg2) (conformantp arg1 arg2))
  278.       (allocate-plural (paralation arg1) 
  279.                (fn (context arg1) (offset arg1) (offset arg2))))
  280.      (t (allocate-plural (paralation (if (pluralp arg1) arg1 arg2))
  281.              (if (pluralp arg1)
  282.                  (fn (context arg1) (offset arg1) 
  283.                  (mp-bang (context arg1) arg2))
  284.                (fn (context arg2) (mp-bang (context arg2) arg1)
  285.                    (offset arg2)))))))
  286.  
  287.   (defun abs-s (arg)
  288.     (if (pluralp arg)
  289.     (allocate-plural (paralation arg)
  290.              (mp-un-op (context arg) (offset arg)     621))
  291.       (error "Arg1 not a plural" clock-tick)))
  292.  
  293.   (defun negate-s (arg)
  294.     (if (pluralp arg)
  295.     (allocate-plural (paralation arg)
  296.              (mp-un-op (context arg) (offset arg)       620))
  297.       (error "Arg1 not a plural" clock-tick)))
  298.  
  299.   (defun delta-s (arg)
  300.     (if (pluralp arg)
  301.     (allocate-plural (paralation arg)
  302.              (mp-un-op (context arg) (offset arg) 670))
  303.       (error "Arg1 not a plural" clock-tick)))
  304.  
  305.   (defun sigma-s (arg)
  306.     (if (pluralp arg)
  307.     (allocate-plural (paralation arg)
  308.              (mp-un-op (context arg) (offset arg) 671))
  309.       (error "Arg1 not a plural" clock-tick)))
  310.  
  311.   (defun eq-s (arg1 arg2)
  312.     (if (conformantp arg1 arg2) 
  313.       (allocate-plural (paralation arg1) 
  314.                (mp-eq (context arg1) (offset arg1) (offset arg2)))
  315.       (error "Incompatible arguments" clock-tick)))
  316.  
  317.   (defun cons-s (arg1 arg2)
  318.     (auto-bang arg1 arg2 mp-cons))
  319.  
  320.   (defun car-s (object)
  321.     (if (pluralp object) 
  322.     (allocate-plural (paralation object)
  323.              (mp-car (context object) (offset object)))
  324.       (error "Arg1 is not a plural" clock-tick)))
  325.  
  326.   (defun cdr-s (object)
  327.     (if (pluralp object)
  328.     (allocate-plural (paralation object)
  329.              (mp-cdr (context object) (offset object)))
  330.       (error "Arg1 is not a plural" clock-tick)))
  331.  
  332.   ((setter setter) car-s 
  333.    (lambda (plural value)
  334.      (if (not (pluralp plural)) (error "Arg1 not a plural" clock-tick)
  335.        (auto-bang plural value mp-rplac-a))))
  336.  
  337.   ((setter setter) cdr-s
  338.    (lambda (plural value)
  339.      (if (not (pluralp plural)) (error "Arg1 not a plural" clock-tick)
  340.        (auto-bang plural value mp-rplac-d))))
  341.  
  342.   (defun make-vector-s (length)
  343.     (if (pluralp length) 
  344.       (allocate-plural (paralation length)
  345.                (mp-make-vector (context length) (offset length)))
  346.       (error "Arg1 not a plural" clock-tick)))
  347.  
  348.   (defun vector-length-s (vector)
  349.     (if (pluralp vector)
  350.       (allocate-plural (paralation vector)
  351.                (mp-vector-length (context vector) (offset vector)))
  352.       (error "Arg1 not a plural" clock-tick)))
  353.  
  354.   (defun vector-ref-s (vector index)
  355.     (if (not (pluralp vector)) (error "Arg1 not a plural" clock-tick)
  356.       (auto-bang vector index mp-vector-ref)))
  357.  
  358.   ((setter setter) vector-ref-s
  359.    (lambda (vector index value)
  360.      (if (not (pluralp vector)) (error "Arg1 not a plural" clock-tick)
  361.        (let ((tmp-index (if (pluralp index) index (bang index vector)))
  362.          (tmp-value (if (pluralp value) value (bang value vector))))
  363.      (if (and (eq (context vector) (context tmp-index))
  364.           (eq (context vector) (context tmp-value)))
  365.        (progn
  366.          (mp-vector-set (context vector) (offset vector)
  367.                 (offset tmp-index) (offset tmp-value))
  368.          vector)
  369.        (error "Non-conformant arguments" clock-tick))))))
  370.  
  371.   (defun consp-s (object)
  372.     (if (pluralp object) 
  373.       (allocate-plural (paralation object) 
  374.                (mp-test (context object) (offset object) 2))
  375.       (error "Arg1 not a plural" clock-tick)))
  376.  
  377. ;  (defun nullp-s (object)
  378. ;    (if (pluralp object) 
  379. ;      (allocate-plural (paralation object)
  380. ;               (mp-test (context object) (offset object) #x7fff))
  381. ;      (error "Arg1 not a plural" clock-tick)))
  382. ;
  383. ; The old hack method doesn't work as nil is now a genuine object on
  384. ; each PE - not just a fancy address
  385.  
  386.   (defun nullp-s (object)
  387.     (if (pluralp object)
  388.       (allocate-plural (paralation object)
  389.                (mp-eq (context object) (offset object) 
  390.                   (mp-bang (context object) ())))
  391.       (error "Arg1 not a plural" clock-tick)))
  392.  
  393.   (defun intp-s (object)
  394.     (if (pluralp object)
  395.       (allocate-plural (paralation object)
  396.                (mp-test (context object) (offset object) 1))
  397.       (error "Arg1 not a plural" clock-tick)))
  398.  
  399.   (defun floatp-s (object)
  400.     (if (pluralp object)
  401.       (allocate-plural (paralation object)
  402.                (mp-test (context object) (offset object) 4))
  403.       (error "Arg1 not a plural" clock-tick)))
  404.  
  405.   (defun vectorp-s (object)
  406.     (if (pluralp object) 
  407.     (allocate-plural (paralation object)
  408.              (mp-test (context object) (offset object) 3))
  409.       (error "Arg1 not a plural" clock-tick)))
  410.  
  411.   (defun scan (p op)
  412.     (allocate-plural (paralation p)
  413.              (mp-scan-op (context p) (offset p)
  414.                  (cond 
  415.                   ((eq op +)     610)
  416.                   ((eq op *) 613)
  417.                   ((eq op max)     660)
  418.                   (t     661)))))
  419.  
  420.   (defun reduce (p op)
  421.     (mp-ref (paralation p)
  422.         (mp-scan-op (context p) (offset p)
  423.             (cond 
  424.              ((eq op +)     610)
  425.              ((eq op *) 613)
  426.              ((equal op 'max) MP_MAX)
  427.              (t     661))) (- (field-length p) 1)))
  428.  
  429.   (defmethod binary-plus ((p1 plural) (p2 plural))
  430.     (if (conformantp p1 p2)
  431.       (allocate-plural 
  432.        (paralation p1) (mp-bin-op (context p1) (offset p1) (offset p2)     610))
  433.       (error "Non-conformant arguments" clock-tick)))
  434.  
  435.   (defmethod binary-difference ((p1 plural) (p2 plural))
  436.     (if (conformantp p1 p2)
  437.       (allocate-plural 
  438.        (paralation p1) (mp-bin-op (context p1) 
  439.                    (offset p1) (offset p2) 611))
  440.       (error "Non-conformant arguments" clock-tick)))
  441.  
  442.   (defmethod binary-times ((p1 plural) (p2 plural))
  443.     (if (conformantp p1 p2)
  444.       (allocate-plural 
  445.        (paralation p1) (mp-bin-op (context p1) 
  446.                    (offset p1) (offset p2) 613))
  447.       (error "Non-conformant arguments" clock-tick)))
  448.  
  449.   (defmethod binary-divide ((p1 plural) (p2 plural))
  450.     (if (conformantp p1 p2)
  451.       (allocate-plural 
  452.        (paralation p1) (mp-bin-op (context p1) 
  453.                    (offset p1) (offset p2) 612))
  454.       (error "Non-conformant arguments" clock-tick)))
  455.  
  456.   (defmethod binary-gt ((p1 plural) (p2 plural))
  457.     (if (conformantp p1 p2)
  458.       (allocate-plural 
  459.        (paralation p1) (mp-rel-op (context p1) 
  460.                    (offset p1) (offset p2)     651))
  461.       (error "Non-conformant arguments" clock-tick)))
  462.  
  463.   (defmethod binary-lt ((p1 plural) (p2 plural))
  464.     (if (conformantp p1 p2)
  465.       (allocate-plural 
  466.        (paralation p1) (mp-rel-op (context p1) 
  467.                    (offset p1) (offset p2)     650))
  468.       (error "Non-conformant arguments" clock-tick)))
  469.  
  470.   (defun remainder-s (arg1 arg2)
  471.     (cond 
  472.      ((not (pluralp arg1)) (error "Arg1 not a plural" clock-tick))
  473.      ((not (pluralp arg2)) (error "Arg2 not a plural" clock-tick))
  474.      ((not (conformantp arg1 arg2)) 
  475.       (error "Non-conformant arguments" clock-tick))
  476.      (t (allocate-plural (paralation arg1) 
  477.              (mp-bin-op (context arg1) (offset arg1) 
  478.                     (offset arg2) 614)))))
  479.  
  480.   (defun and-s (arg1 arg2)
  481.     (auto-bang arg1 arg2 mp-and))
  482.  
  483.   (defun or-s (arg1 arg2)
  484.     (auto-bang arg1 arg2 mp-or))
  485.  
  486.   (defclass mapping (mp-object)
  487.     ()
  488.     constructor (allocate-mapping paralation offset)
  489.     predicate mappingp)
  490.  
  491.   (defun match (to from)
  492.     (if (and (pluralp from) (pluralp to))
  493.       (allocate-mapping (paralation to) (mp-match (context to) (offset to)
  494.                            (context from) (offset from)))
  495.       (error "Both args should be plurals" clock-tick)))
  496.  
  497.   (defun move (data map with default)
  498.     (cond
  499.      ((not (pluralp data)) (error "Arg1 msut be a plural" clock-tick))
  500.      ((not (mappingp map)) (error "Arg2 must be a mapping" clock-tick))
  501.      (t (let ((moved (allocate-plural (paralation map) 
  502.                       (mp-move (context data) (offset data)
  503.                            (context map) (offset map)))))
  504.       (labels ((recurse (list-s cdr-list-s)
  505.              (if-s-internal cdr-list-s 
  506.                (lambda () (with (car-s list-s) 
  507.                  (recurse cdr-list-s (cdr-s cdr-list-s))))
  508.                (lambda () (car-s list-s)))))
  509.         (if-s-internal moved (lambda () (recurse moved (cdr-s moved)))
  510.           (lambda () (bang default moved))))))))
  511.  
  512. ; Modification to mp-move - plural for result has to be preallocated
  513.  
  514.   (defun move (data map with default)
  515.     (cond
  516.      ((not (pluralp data)) (error "Arg1 msut be a plural" clock-tick))
  517.      ((not (mappingp map)) (error "Arg2 must be a mapping" clock-tick))
  518.      (t (let ((moved (allocate-plural (paralation map) 
  519.                       (mp-make-plural (context map)))))
  520.       (mp-move (context data) (offset data)
  521.            (context map) (offset map) (offset moved))
  522.       (labels ((recurse (list-s cdr-list-s)
  523.              (if-s-internal cdr-list-s 
  524.                (lambda () (with (car-s list-s) 
  525.                  (recurse cdr-list-s (cdr-s cdr-list-s))))
  526.                (lambda () (car-s list-s)))))
  527.         (if-s-internal moved (lambda () (recurse moved (cdr-s moved)))
  528.           (lambda () (bang default moved))))))))
  529.  
  530.   (defun ll-move (data map)
  531.     (cond 
  532.      ((not (pluralp data)) (error "Arg1 must be a plural" clock-tick))
  533.      ((not (mapping  map)) (error "Arg2 must be a mapping" clock-tick))
  534.      (t (allocate-plurak (paralation map)
  535.              (mp-move (context data) (offset data) 
  536.                   (context map)  (ofset map))))))
  537.  
  538.   (defun look-at-mapping (map)
  539.     (if (mappingp map)
  540.       (allocate-plural (paralation map) (offset map))
  541.       (error "Arg1 should be a map" clock-tick)))
  542.   (defun visualise (p)
  543.     (if (pluralp p) (progn 
  544.                (mp-x-stat (context p) (offset p))
  545.                p)
  546.       (error "Arg1 not a plural")))
  547.  
  548. (export match move make-plural plural-length bang plural-ref 
  549.     list-to-plural eq-s if-s if-s-internal cons-s car-s cdr-s 
  550.     and-s or-s visualise
  551.     abs-s negate-s sigma-s delta-s
  552.     make-vector-s vector-length-s vector-ref-s
  553.     consp-s nullp-s intp-s floatp-s vectorp-s
  554.     ll-move mp-gc)
  555.  
  556. )
  557.  
  558.  
  559. ; This function probably needs adding, this is its hacked from CM-Lisp
  560. ; form
  561.  
  562. ;   (defun put (x at in)
  563. ;     (cond 
  564. ;      ((not (xecp in)) (error "Destination (arg 2) is not a xec" clock-tick))
  565. ;      ((not (conformantp x at)) 
  566. ;       (error "Values and indexes not conformant" clock-tick))
  567. ;      (t (let ((ctxt-x  (context x))
  568. ;           (ofst-at (offset at))
  569. ;           (ctxt-in (context in)))
  570. ;       (allocate-xec 
  571. ;        ctxt-in
  572. ;        (cm-put ctxt-x (offset x)
  573. ;            (mp-bin-op ctxt-x ofst-at
  574. ;                   (mp-bin-op ctxt-x ofst-at
  575. ;                      (mp-bang ctxt-x (cm-start in))))))))))
  576.  
  577.  
  578.  
  579.  
  580.  
  581.  
  582.  
  583.  
  584.  
  585.  
  586.  
  587.  
  588.  
  589.  
  590.  
  591.  
  592.